home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xlisp_21.zoo / xleval.c < prev    next >
C/C++ Source or Header  |  1990-02-28  |  19KB  |  869 lines
  1. /* xleval - xlisp evaluator */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* macro to check for lambda list keywords */
  9. #define iskey(s) ((s) == lk_optional \
  10.                || (s) == lk_rest \
  11.                || (s) == lk_key \
  12.                || (s) == lk_aux \
  13.                || (s) == lk_allow_other_keys)
  14.  
  15. /* macros to handle tracing */
  16. #define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
  17. #define trexit(sym,val) {if (sym) doexit(sym,val);}
  18.  
  19. /* external variables */
  20. extern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
  21. extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
  22. extern LVAL s_evalhook,s_applyhook,s_tracelist;
  23. extern LVAL s_lambda,s_macro;
  24. extern LVAL s_unbound;
  25. extern int xlsample;
  26. extern char buf[];
  27.  
  28. /* forward declarations */
  29. FORWARD LVAL xlxeval();
  30. FORWARD LVAL evalhook();
  31. FORWARD LVAL evform();
  32. FORWARD LVAL evfun();
  33.  
  34. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  35. LVAL xleval(expr)
  36.   LVAL expr;
  37. {
  38.     /* check for control codes */
  39.     if (--xlsample <= 0) {
  40.     xlsample = SAMPLE;
  41.     oscheck();
  42.     }
  43.  
  44.     /* check for *evalhook* */
  45.     if (getvalue(s_evalhook))
  46.     return (evalhook(expr));
  47.  
  48.     /* check for nil */
  49.     if (null(expr))
  50.     return (NIL);
  51.  
  52.     /* dispatch on the node type */
  53.     switch (ntype(expr)) {
  54.     case CONS:
  55.     return (evform(expr));
  56.     case SYMBOL:
  57.     return (xlgetvalue(expr));
  58.     default:
  59.     return (expr);
  60.     }
  61. }
  62.  
  63. /* xlevalenv - evaluate an expression in a specified environment */
  64. LVAL xlevalenv(expr,env,fenv)
  65.   LVAL expr,env,fenv;
  66. {
  67.     LVAL oldenv,oldfenv,val;
  68.  
  69.     /* protect some pointers */
  70.     xlstkcheck(2);
  71.     xlsave(oldenv);
  72.     xlsave(oldfenv);
  73.  
  74.     /* establish the new environment */
  75.     oldenv = xlenv;
  76.     oldfenv = xlfenv;
  77.     xlenv = env;
  78.     xlfenv = fenv;
  79.  
  80.     /* evaluate the expression */
  81.     val = xleval(expr);
  82.  
  83.     /* restore the environment */
  84.     xlenv = oldenv;
  85.     xlfenv = oldfenv;
  86.  
  87.     /* restore the stack */
  88.     xlpopn(2);
  89.  
  90.     /* return the result value */
  91.     return (val);
  92. }
  93.  
  94. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  95. LVAL xlxeval(expr)
  96.   LVAL expr;
  97. {
  98.     /* check for nil */
  99.     if (null(expr))
  100.     return (NIL);
  101.  
  102.     /* dispatch on node type */
  103.     switch (ntype(expr)) {
  104.     case CONS:
  105.     return (evform(expr));
  106.     case SYMBOL:
  107.     return (xlgetvalue(expr));
  108.     default:
  109.     return (expr);
  110.     }
  111. }
  112.  
  113. /* xlapply - apply a function to arguments (already on the stack) */
  114. LVAL xlapply(argc)
  115.   int argc;
  116. {
  117.     LVAL *oldargv,fun,val;
  118.     int oldargc;
  119.     
  120.     /* get the function */
  121.     fun = xlfp[1];
  122.  
  123.     /* get the functional value of symbols */
  124.     if (symbolp(fun)) {
  125.     while ((val = getfunction(fun)) == s_unbound)
  126.         xlfunbound(fun);
  127.     fun = xlfp[1] = val;
  128.     }
  129.  
  130.     /* check for nil */
  131.     if (null(fun))
  132.     xlerror("bad function",fun);
  133.  
  134.     /* dispatch on node type */
  135.     switch (ntype(fun)) {
  136.     case SUBR:
  137.     oldargc = xlargc;
  138.     oldargv = xlargv;
  139.     xlargc = argc;
  140.     xlargv = xlfp + 3;
  141.     val = (*getsubr(fun))();
  142.     xlargc = oldargc;
  143.     xlargv = oldargv;
  144.     break;
  145.     case CONS:
  146.     if (!consp(cdr(fun)))
  147.         xlerror("bad function",fun);
  148.     if (car(fun) == s_lambda)
  149.         fun = xlclose(NIL,
  150.                       s_lambda,
  151.                       car(cdr(fun)),
  152.                       cdr(cdr(fun)),
  153.                       xlenv,xlfenv);
  154.     else
  155.         xlerror("bad function",fun);
  156.     /**** fall through into the next case ****/
  157.     case CLOSURE:
  158.     if (gettype(fun) != s_lambda)
  159.         xlerror("bad function",fun);
  160.     val = evfun(fun,argc,xlfp+3);
  161.     break;
  162.     default:
  163.     xlerror("bad function",fun);
  164.     }
  165.  
  166.     /* remove the call frame */
  167.     xlsp = xlfp;
  168.     xlfp = xlfp - (int)getfixnum(*xlfp);
  169.  
  170.     /* return the function value */
  171.     return (val);
  172. }
  173.  
  174. /* evform - evaluate a form */
  175. LOCAL LVAL evform(form)
  176.   LVAL form;
  177. {
  178.     LVAL fun,args,val,type;
  179.     LVAL tracing=NIL;
  180.     LVAL *argv;
  181.     int argc;
  182.  
  183.     /* protect some pointers */
  184.     xlstkcheck(2);
  185.     xlsave(fun);
  186.     xlsave(args);
  187.  
  188.     /* get the function and the argument list */
  189.     fun = car(form);
  190.     args = cdr(form);
  191.  
  192.     /* get the functional value of symbols */
  193.     if (symbolp(fun)) {
  194.     if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
  195.         tracing = fun;
  196.     fun = xlgetfunction(fun);
  197.     }
  198.  
  199.     /* check for nil */
  200.     if (null(fun))
  201.     xlerror("bad function",NIL);
  202.  
  203.     /* dispatch on node type */
  204.     switch (ntype(fun)) {
  205.     case SUBR:
  206.     argv = xlargv;
  207.     argc = xlargc;
  208.     xlargc = evpushargs(fun,args);
  209.     xlargv = xlfp + 3;
  210.     trenter(tracing,xlargc,xlargv);
  211.     val = (*getsubr(fun))();
  212.     trexit(tracing,val);
  213.     xlsp = xlfp;
  214.     xlfp = xlfp - (int)getfixnum(*xlfp);
  215.     xlargv = argv;
  216.     xlargc = argc;
  217.     break;
  218.     case FSUBR:
  219.     argv = xlargv;
  220.     argc = xlargc;
  221.     xlargc = pushargs(fun,args);
  222.     xlargv = xlfp + 3;
  223.     val = (*getsubr(fun))();
  224.     xlsp = xlfp;
  225.     xlfp = xlfp - (int)getfixnum(*xlfp);
  226.     xlargv = argv;
  227.     xlargc = argc;
  228.     break;
  229.     case CONS:
  230.     if (!consp(cdr(fun)))
  231.         xlerror("bad function",fun);
  232.     if ((type = car(fun)) == s_lambda)
  233.          fun = xlclose(NIL,
  234.                        s_lambda,
  235.                        car(cdr(fun)),
  236.                        cdr(cdr(fun)),
  237.                        xlenv,xlfenv);
  238.     else
  239.         xlerror("bad function",fun);
  240.     /**** fall through into the next case ****/
  241.     case CLOSURE:
  242.     if (gettype(fun) == s_lambda) {
  243.         argc = evpushargs(fun,args);
  244.         argv = xlfp + 3;
  245.         trenter(tracing,argc,argv);
  246.         val = evfun(fun,argc,argv);
  247.         trexit(tracing,val);
  248.         xlsp = xlfp;
  249.         xlfp = xlfp - (int)getfixnum(*xlfp);
  250.     }
  251.     else {
  252.         macroexpand(fun,args,&fun);
  253.         val = xleval(fun);
  254.     }
  255.     break;
  256.     default:
  257.     xlerror("bad function",fun);
  258.     }
  259.  
  260.     /* restore the stack */
  261.     xlpopn(2);
  262.  
  263.     /* return the result value */
  264.     return (val);
  265. }
  266.  
  267. /* xlexpandmacros - expand macros in a form */
  268. LVAL xlexpandmacros(form)
  269.   LVAL form;
  270. {
  271.     LVAL fun,args;
  272.     
  273.     /* protect some pointers */
  274.     xlstkcheck(3);
  275.     xlprotect(form);
  276.     xlsave(fun);
  277.     xlsave(args);
  278.  
  279.     /* expand until the form isn't a macro call */
  280.     while (consp(form)) {
  281.     fun = car(form);        /* get the macro name */
  282.     args = cdr(form);        /* get the arguments */
  283.     if (!symbolp(fun) || !fboundp(fun))
  284.         break;
  285.     fun = xlgetfunction(fun);    /* get the expansion function */
  286.     if (!macroexpand(fun,args,&form))
  287.         break;
  288.     }
  289.  
  290.     /* restore the stack and return the expansion */
  291.     xlpopn(3);
  292.     return (form);
  293. }
  294.  
  295. /* macroexpand - expand a macro call */
  296. int macroexpand(fun,args,pval)
  297.   LVAL fun,args,*pval;
  298. {
  299.     LVAL *argv;
  300.     int argc;
  301.     
  302.     /* make sure it's really a macro call */
  303.     if (!closurep(fun) || gettype(fun) != s_macro)
  304.     return (FALSE);
  305.     
  306.     /* call the expansion function */
  307.     argc = pushargs(fun,args);
  308.     argv = xlfp + 3;
  309.     *pval = evfun(fun,argc,argv);
  310.     xlsp = xlfp;
  311.     xlfp = xlfp - (int)getfixnum(*xlfp);
  312.     return (TRUE);
  313. }
  314.  
  315. /* evalhook - call the evalhook function */
  316. LOCAL LVAL evalhook(expr)
  317.   LVAL expr;
  318. {
  319.     LVAL *newfp,olddenv,val;
  320.  
  321.     /* create the new call frame */
  322.     newfp = xlsp;
  323.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  324.     pusharg(getvalue(s_evalhook));
  325.     pusharg(cvfixnum((FIXTYPE)2));
  326.     pusharg(expr);
  327.     pusharg(cons(xlenv,xlfenv));
  328.     xlfp = newfp;
  329.  
  330.     /* rebind the hook functions to nil */
  331.     olddenv = xldenv;
  332.     xldbind(s_evalhook,NIL);
  333.     xldbind(s_applyhook,NIL);
  334.  
  335.     /* call the hook function */
  336.     val = xlapply(2);
  337.  
  338.     /* unbind the symbols */
  339.     xlunbind(olddenv);
  340.  
  341.     /* return the value */
  342.     return (val);
  343. }
  344.  
  345. /* evpushargs - evaluate and push a list of arguments */
  346. LOCAL int evpushargs(fun,args)
  347.   LVAL fun,args;
  348. {
  349.     LVAL *newfp;
  350.     int argc;
  351.     
  352.     /* protect the argument list */
  353.     xlprot1(args);
  354.  
  355.     /* build a new argument stack frame */
  356.     newfp = xlsp;
  357.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  358.     pusharg(fun);
  359.     pusharg(NIL); /* will be argc */
  360.  
  361.     /* evaluate and push each argument */
  362.     for (argc = 0; consp(args); args = cdr(args), ++argc)
  363.     pusharg(xleval(car(args)));
  364.  
  365.     /* establish the new stack frame */
  366.     newfp[2] = cvfixnum((FIXTYPE)argc);
  367.     xlfp = newfp;
  368.     
  369.     /* restore the stack */
  370.     xlpop();
  371.  
  372.     /* return the number of arguments */
  373.     return (argc);
  374. }
  375.  
  376. /* pushargs - push